perm filename MOVIT.F4[P11,LCS]2 blob sn#573354 filedate 1981-03-16 generic text, type T, neo UTF8
00100	C****** SUBRS  MOVIT, OUTLMT, GETPTS, GUPDAT, DELETE, STFCH,COPYIT,CPYIT
00150	C--- FROM MOVE.FAI=GETPTS,MOVIT,COPYIT,STFCH,DELETE
00200		SUBROUTINE MOVIT(RN,NP,R4,R5,R8,R9)
00300	 	DIMENSION  NP(1),RN(1)
00400	 	COMMON  /KJY/ NO,J
00500		RDIS=(R9-R8)/(R5-R4)
00600	 	DO 1 K=1,J
00700	       	L=NP(K)
00800		RA=RN(L)
00900	   	IF(OUTLMT(R4,R5,RA))GO TO 1
01000		IF(R9.NE.0)RA=(RA-R4)*RDIS
01100		RN(L)=R8+RA
01200	1	CONTINUE
01300		END
01400	 
01500		FUNCTION OUTLMT(A,B,R)
01600	C TELLS IF POINT IS WITHIN BOUNDS OF A-B (PUT THIS INTO MACRO)
01700		OUTLMT=-1.
01800		IF(R.LT.A)RETURN
01900		IF(R.GT.B)RETURN
02000		OUTLMT=0
02100		END
02200	 
02300	 	SUBROUTINE GETPTS(NN)
02400	C NN IS FIRST ITEM TO LOOK AT
02500		INTEGER PWDS
02600		COMMON/XRN/RN(1)  /KJY/ K,J /POSI/STFF(8),JJ2
02700		COMMON R2,JA,CENTR,J2,RJQ(18),RX6,JR,L,RDIS,VY,JQ(17)
02800		1/PTR/PWDS(1) /RINP/R(500),N(350),NP(250) /LIMIT/LIM,ITEM
02900		EQUIVALENCE (R4,RJQ(2)),(R5,RJQ(3)),(R6,RJQ(4))
03000		J=0
03100		K=0
03200	C J AND K ARE COUNTERS FOR N AND NP ARRAYS.
03300		DO 1 M=NN,ITEM
03400		L=PWDS(M)
03500		RY=RN(L+1)
03600		IF(R2.GE.8)GO TO 3
03700	C >=8 MEANS LOOK AT ALL STAVES
03800		IF(R2.NE.RN(L+2))GO TO 1
03900	C SKIP IF NOT RIGHT STAFF NUM.
04000	3	IF(R6.LE.0)GO TO 9
04100	C  CHECK CODE NUM
04200		IF(R6.NE.RY)GO TO 1
04300	9	IF(OUTLMT(R4,R5,RN(L+3)))GO TO 2
04400	C  IN LIMITS?
04500		CALL GUPDAT(M,L,3)
04600	C GO PUT AWAY POINTER TO P3 OF THIS ITEM
04700		K=K+1
04800		NP(K)=L
04900	C  NP SAVES POINTER TO P3 FOR USE IN JUSTIFY ROUTINE
05000	2	CNT=RN(L)
05100	C  GET THE WD CNT
05200		IF(RY.EQ.2)GO TO 8
05300	C FOR 'CENTERED' RESTS
05400		IF(RY.LT.4)GO TO 1
05500		IF(RY.GT.7)GO TO 1
05600		IF(RY.EQ.6)GO TO 6
05700	C  TWO-ENDED ITEM?
05800	7	IF(CNT.GT.3)GO TO 5
05900		GO TO 1
06000	6	IF(CNT.LT.8)GO TO 8
06100		IF(RN(L+7).LT.0)GO TO 8
06200		IF(RN(L+10).EQ.0)GO TO 8
06300		IF(RN(L+8).LE.0)GO TO 8
06400	C IGNORE P8 IF IT IS 0 OR -
06500		IF(OUTLMT(R4,R5,RN(L+8)))GO TO 8
06600	C  IN LIMITS?
06700		CALL GUPDAT(M,L,8)
06800	C PUT AWAY POINTER TO P8 FOR THIS BEAM
06900	8	IF(CNT.LT.7)GO TO 5
07000		 IF(RN(L+9).LE.0)GO TO 5
07100	C  WON'T LOOK AT NEG. POS.
07200		IF(RY.EQ.2)GO TO 10
07300	C   (NEW REST CENTERING)
07400		IF(RN(L+8).NE.0)GO TO 10
07500		IF(RN(L+7).GE.0)GO TO 5
07600	C    USE R9 IF R9<0 AND (R8≠0 OR R7<0)
07700	10	IF(OUTLMT(R4,R5,RN(L+9)))GO TO 1
07800	C  IN LIMITS?
07900		CALL GUPDAT(M,L,9)
08000	5	IF(RY.EQ.2)GO TO 1
08100		IF(OUTLMT(R4,R5,RN(L+6)))GO TO 1
08200	C  IN LIMITS?
08300		CALL GUPDAT(M,L,6)
08400	C PUT AWAY POINTER TO P6 FOR ALL 2-SIDED ITEMS.
08500	1	CONTINUE
08600		END
08700	
08800		SUBROUTINE GUPDAT(M,L,KK)
08900		COMMON /KJY/ K,J /POSI/STFF(8),JJ2 /RINP/R(500),N(350),NP(250)
09000		J=J+1
09100		N(J)=L+KK
09200	C SETS UP POINTERS FOR USE IN MOVES, ETC.
09300		IF(M.LT.JJ2)JJ2=M
09400		END
09500	
09600		SUBROUTINE DELETE
09700		IMPLICIT INTEGER(A-Q,S-Z)
09800		COMMON/DL/X22,SAVER,NAME /XRN/RN(1)
09900		COMMON R2,JA,CENTR,J2,RJQ(20),JQ(15),R6,DEL,X,JY,K
10000		COMMON/PTR/PWDS(1) /LIMIT/LIM,ITEM,L,I,IX
10100		1 /DPY/ST(4000),MEDIT,IGO  /DPTR/WDS(350)
10200		EQUIVALENCE (ST2,ST(2))
10300	    	IX=I
10400		L=RN(MEDIT)+3
10500	C  SIZE OF DELETION
10600		I=IX-L
10700		CALL LOOP(MEDIT,I,1,0,L,RN)
10800		JY=WDS(X22+1)-WDS(X22)
10900		CALL LOOP(WDS(X22)+2,WDS(ITEM),1,0,JY,ST)
11000		K=X22
11100	194	 N=K+1
11200		WDS(N)=WDS(N+1)-JY
11300		PWDS(K)=PWDS(N)-L
11400		K=N
11500		IF(K.LT.ITEM)GO TO 194
11600	C  ABOVE RESHUFFLES POINTER ARRAYS. X=ITEM+1
11700		ITEM=ITEM-1
11800		IF(X22.GT.ITEM)X22=ITEM
11900		J2=ITEM
12000		ITEM=ITEM-1
12100		ST2=WDS(J2)
12200	271	CALL DPYNEW
12300		END
12400	 
12500		SUBROUTINE STFCH
12600		CALL CPYIT(1)
12700		END
12800		SUBROUTINE COPYIT
12900		CALL CPYIT(0)
13000		END
13100	
13200		SUBROUTINE CPYIT(KC)
13300		INTEGER PWDS
13400		COMMON/XRN/RN(1) /POSI/S(8),JJ2,P
13500		COMMON R2,JA,CENTR,J2,RJQ(18),RX6,JR,L,RDIS,VY,JQ(17)
13600		1/PTR/PWDS(1) /LIMIT/LIM,ITEM,LL,I,IX
13700	 	EQUIVALENCE (R4,RJQ(2)),(R5,RJQ(3)),(R7,RJQ(5))
13800	 	1,(R6,RJQ(4))
13900	
14000	C KC IS FLAG FOR STFCH ROUTINE
14100		IM=ITEM
14200		DO 1 K=1,IM
14300		L=PWDS(K)
14400		IF(RTLINE(L))GO TO 1
14500		IF(OUTLMT(R4,R5,RN(L+3)))GO TO 1
14600		IF(R6.NE.0.AND.R6.NE.RN(L+1))GO TO 1
14700		IF(KC.NE.0)GO TO 2
14800		M=RN(L)+2
14900		CALL LOOP(0,M,1,I,L,RN)
15000		ITEM=ITEM+1
15100		L=PWDS(ITEM)
15200	2	IF(R7.LE.7.)RN(L+2)=R7
15300		IF(KC.EQ.0)GO TO 3
15400		IF(K.LT.JJ2)JJ2=K
15500		GO TO 1 
15600	3	IF(ITEM.LT.JJ2)JJ2=ITEM
15700		I=I+M+1
15800		PWDS(ITEM+1)=I
15900	 1	CONTINUE
16000		IF(KC.EQ.0)R2=R7
16100		END